home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / ActiveX_Co1799029302004.psc / ActiveX Coder 4 / Classes / CToolTip.cls < prev   
Text File  |  2004-04-17  |  8KB  |  277 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CTooltip"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. Option Explicit
  17.  
  18. Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
  19.  
  20. ''Windows API Functions
  21. Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
  22. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  23. Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  24. Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
  25.  
  26. ''Windows API Constants
  27. Private Const WM_USER = &H400
  28. Private Const CW_USEDEFAULT = &H80000000
  29.  
  30. ''Windows API Types
  31. Private Type RECT
  32.         Left As Long
  33.         Top As Long
  34.         Right As Long
  35.         Bottom As Long
  36. End Type
  37.  
  38. ''Tooltip Window Constants
  39. Private Const TTS_NOPREFIX = &H2
  40. Private Const TTF_TRANSPARENT = &H100
  41. Private Const TTF_CENTERTIP = &H2
  42. Private Const TTM_ADDTOOLA = (WM_USER + 4)
  43. Private Const TTM_ACTIVATE = WM_USER + 1
  44. Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
  45. Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
  46. Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
  47. Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
  48. Private Const TTM_SETTITLE = (WM_USER + 32)
  49. Private Const TTS_BALLOON = &H40
  50. Private Const TTS_ALWAYSTIP = &H1
  51. Private Const TTF_SUBCLASS = &H10
  52. Private Const TTF_IDISHWND = &H1
  53. Private Const TTM_SETDELAYTIME = (WM_USER + 3)
  54. Private Const TTDT_AUTOPOP = 2
  55. Private Const TTDT_INITIAL = 3
  56.  
  57. Private Const TOOLTIPS_CLASSA = "tooltips_class32"
  58.  
  59. ''Tooltip Window Types
  60. Private Type TOOLINFO
  61.     lSize As Long
  62.     lFlags As Long
  63.     hwnd As Long
  64.     lId As Long
  65.     lpRect As RECT
  66.     hInstance As Long
  67.     lpStr As String
  68.     lParam As Long
  69. End Type
  70.  
  71.  
  72. Public Enum ttIconType
  73.     TTNoIcon = 0
  74.     TTIconInfo = 1
  75.     TTIconWarning = 2
  76.     TTIconError = 3
  77. End Enum
  78.  
  79. Public Enum ttStyleEnum
  80.     TTStandard
  81.     TTBalloon
  82. End Enum
  83.  
  84. 'local variable(s) to hold property value(s)
  85. Private mvarBackColor As Long
  86. Private mvarTitle As String
  87. Private mvarForeColor As Long
  88. Private mvarIcon As ttIconType
  89. Private mvarCentered As Boolean
  90. Private mvarStyle As ttStyleEnum
  91. Private mvarTipText As String
  92. Private mvarVisibleTime As Long
  93. Private mvarDelayTime As Long
  94.  
  95. 'private data
  96. Private m_lTTHwnd As Long ' hwnd of the tooltip
  97. Private m_lParentHwnd As Long ' hwnd of the window the tooltip attached to
  98. Private ti As TOOLINFO
  99.  
  100. Public Property Let Style(ByVal vData As ttStyleEnum)
  101.    'used when assigning a value to the property, on the left side of an assignment.
  102.    'Syntax: X.Style = 5
  103.    mvarStyle = vData
  104. End Property
  105.  
  106. Public Property Get Style() As ttStyleEnum
  107.    'used when retrieving value of a property, on the right side of an assignment.
  108.    'Syntax: Debug.Print X.Style
  109.    Style = mvarStyle
  110. End Property
  111.  
  112. Public Property Let Centered(ByVal vData As Boolean)
  113.    'used when assigning a value to the property, on the left side of an assignment.
  114.    'Syntax: X.Centered = 5
  115.    mvarCentered = vData
  116. End Property
  117.  
  118. Public Property Get Centered() As Boolean
  119.    'used when retrieving value of a property, on the right side of an assignment.
  120.    'Syntax: Debug.Print X.Centered
  121.    Centered = mvarCentered
  122. End Property
  123.  
  124. Public Function Create(ByVal ParentHwnd As Long) As Boolean
  125.    Dim lWinStyle As Long
  126.    
  127.    If m_lTTHwnd <> 0 Then
  128.       DestroyWindow m_lTTHwnd
  129.    End If
  130.    
  131.    m_lParentHwnd = ParentHwnd
  132.    
  133.    lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
  134.    
  135.    ''create baloon style if desired
  136.    If mvarStyle = TTBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON
  137.     
  138.    m_lTTHwnd = CreateWindowEx(0&, _
  139.       TOOLTIPS_CLASSA, _
  140.       vbNullString, _
  141.       lWinStyle, _
  142.       CW_USEDEFAULT, _
  143.       CW_USEDEFAULT, _
  144.       CW_USEDEFAULT, _
  145.       CW_USEDEFAULT, _
  146.       0&, _
  147.       0&, _
  148.       App.hInstance, _
  149.       0&)
  150.                
  151.    ''now set our tooltip info structure
  152.    With ti
  153.       ''if we want it centered, then set that flag
  154.       If mvarCentered Then
  155.          .lFlags = TTF_SUBCLASS Or TTF_CENTERTIP Or TTF_IDISHWND
  156.       Else
  157.          .lFlags = TTF_SUBCLASS Or TTF_IDISHWND
  158.       End If
  159.        
  160.       ''set the hwnd prop to our parent control's hwnd
  161.       .hwnd = m_lParentHwnd
  162.       .lId = m_lParentHwnd '0
  163.       .hInstance = App.hInstance
  164.       '.lpstr = ALREADY SET
  165.       '.lpRect = lpRect
  166.       .lSize = Len(ti)
  167.    End With
  168.    
  169.    ''add the tooltip structure
  170.    SendMessage m_lTTHwnd, TTM_ADDTOOLA, 0&, ti
  171.  
  172.    ''if we want a title or we want an icon
  173.    If mvarTitle <> vbNullString Or mvarIcon <> TTNoIcon Then
  174.       SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
  175.    End If
  176.  
  177.    If mvarForeColor <> Empty Then
  178.       SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
  179.    End If
  180.  
  181.    If mvarBackColor <> Empty Then
  182.       SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
  183.    End If
  184.    
  185.    SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, mvarVisibleTime
  186.    SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, mvarDelayTime
  187. End Function
  188.  
  189. Public Property Let Icon(ByVal vData As ttIconType)
  190.    mvarIcon = vData
  191.    If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
  192.       SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
  193.    End If
  194. End Property
  195.  
  196. Public Property Get Icon() As ttIconType
  197.    Icon = mvarIcon
  198. End Property
  199.  
  200. Public Property Let ForeColor(ByVal vData As Long)
  201.    mvarForeColor = vData
  202.    If m_lTTHwnd <> 0 Then
  203.       SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
  204.    End If
  205. End Property
  206.  
  207. Public Property Get ForeColor() As Long
  208.    ForeColor = mvarForeColor
  209. End Property
  210.  
  211. Public Property Let Title(ByVal vData As String)
  212.    mvarTitle = vData
  213.    If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
  214.       SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
  215.    End If
  216. End Property
  217.  
  218. Public Property Get Title() As String
  219.    Title = ti.lpStr
  220. End Property
  221.  
  222. Public Property Let BackColor(ByVal vData As Long)
  223.    mvarBackColor = vData
  224.    If m_lTTHwnd <> 0 Then
  225.       SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
  226.    End If
  227. End Property
  228.  
  229. Public Property Get BackColor() As Long
  230.    BackColor = mvarBackColor
  231. End Property
  232.  
  233. Public Property Let TipText(ByVal vData As String)
  234.    mvarTipText = vData
  235.    ti.lpStr = vData
  236.    If m_lTTHwnd <> 0 Then
  237.       SendMessage m_lTTHwnd, TTM_UPDATETIPTEXTA, 0&, ti
  238.    End If
  239. End Property
  240.  
  241. Public Property Get TipText() As String
  242.    TipText = mvarTipText
  243. End Property
  244.  
  245. Private Sub Class_Initialize()
  246.    InitCommonControls
  247.    mvarDelayTime = 500
  248.    mvarVisibleTime = 5000
  249. End Sub
  250.  
  251. Private Sub Class_Terminate()
  252.    Destroy
  253. End Sub
  254.  
  255. Public Sub Destroy()
  256.    If m_lTTHwnd <> 0 Then
  257.       DestroyWindow m_lTTHwnd
  258.    End If
  259. End Sub
  260.  
  261. Public Property Get VisibleTime() As Long
  262.    VisibleTime = mvarVisibleTime
  263. End Property
  264.  
  265. Public Property Let VisibleTime(ByVal lData As Long)
  266.    mvarVisibleTime = lData
  267. End Property
  268.  
  269. Public Property Get DelayTime() As Long
  270.    DelayTime = mvarDelayTime
  271. End Property
  272.  
  273. Public Property Let DelayTime(ByVal lData As Long)
  274.    mvarDelayTime = lData
  275. End Property
  276.  
  277.